home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Taifun / Taifun 121 (1990-02-15)(Ossowski, Stefan)(DE)(PD).zip / Taifun 121 (1990-02-15)(Ossowski, Stefan)(DE)(PD).adf / WBShadow / RealWBShadow.mod < prev    next >
Text File  |  1989-11-08  |  6KB  |  207 lines
  1. (*---------------------------------------------------------------------------
  2.   :Program.    RealWBShadow.mod
  3.   :Author.     Fridtjof Siebert
  4.   :Address.    Nobileweg 67, D-7-Stgt-40
  5.   :Shortcut.   [fbs]
  6.   :Version.    1.0
  7.   :Date.       26-Jan-89
  8.   :Copyright.  PD
  9.   :Language.   Modula-II
  10.   :Translator. M2Amiga v3.1d
  11.   :Imports.    arp.library
  12.   :Contents.   Program to create shadows of the things on your Workbench
  13.   :Remark.     It's terrible! Everything I program is senseless!!
  14. ---------------------------------------------------------------------------*)
  15.  
  16. MODULE RealWBShadow;
  17.  
  18. FROM SYSTEM      IMPORT ADR, ADDRESS, LONGSET, CAST, BITSET;
  19. FROM Arts        IMPORT Assert, TermProcedure, Terminate;
  20. FROM Dos         IMPORT Delay;
  21. FROM Exec        IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
  22.                         Message, MessagePtr, GetMsg, ReplyMsg, PutMsg,
  23.                         WaitPort;
  24. FROM ExecSupport IMPORT CreatePort, DeletePort;
  25. FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, NewWindow,
  26.                         WindowFlags, WindowFlagSet, ScreenFlags, CloseWindow,
  27.                         ScreenFlagSet, IDCMPFlagSet, OpenWindow, WindowPtr;
  28. FROM Graphics    IMPORT BitMap, BltBitMap;
  29. FROM Heap        IMPORT AllocMem;
  30.  
  31. (*------  CONSTS:  ------*)
  32.  
  33. CONST
  34.   WindowTitle = "WBShadow © Fridtjof Siebert / AMOK Stuttgart";
  35.   PortName    = "NewWBPlanes[fbs].Port";
  36.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  37.  
  38. (*------  TYPES:  ------*)
  39.  
  40. TYPE
  41.   ColorMap = ARRAY[0..31] OF INTEGER;
  42.  
  43. (*------  VARS:  ------*)
  44.  
  45. VAR
  46.   WBScreen: ScreenPtr;
  47.   NewPlane1, NewPlane2, OldPlane1, OldPlane2: ADDRESS;
  48.   OldbPR, OldRows: CARDINAL;
  49.   ColTable: POINTER TO ColorMap;
  50.   Window: WindowPtr;
  51.   NuWindow: NewWindow;
  52.   MyMsg: Message;
  53.   QuitMessage: MessagePtr;
  54.   MyPort, OldPort: MsgPortPtr;
  55.   l: LONGINT;
  56.   bm: BitMap;
  57.  
  58. (*------  CleanUp:  ------*)
  59.  
  60. PROCEDURE CleanUp();
  61.  
  62. BEGIN
  63.  
  64. (*------  Remove Picture from WB:  ------*)
  65.  
  66.   IF WBScreen#NIL THEN
  67.     Forbid();
  68.       WITH WBScreen^ DO
  69.         WITH bitMap DO
  70.           depth := 2;
  71.           planes[2] := NIL;
  72.           IF OldPlane1#NIL THEN planes[0] := OldPlane1;
  73.             IF OldPlane2#NIL THEN planes[1] := OldPlane2;
  74.               IF OldRows#0 THEN rows := OldRows;
  75.                 IF OldbPR#0 THEN bytesPerRow := OldbPR;
  76.                   l := BltBitMap(ADR(bm),16,8,ADR(bitMap),0,0,
  77.                                  width,height,0C0H,3,NIL);
  78.                 END;
  79.               END;
  80.             END;
  81.           END;
  82.         END;
  83.       END;
  84.       MakeScreen(WBScreen);
  85.     Permit();
  86.     RethinkDisplay();
  87.   END;
  88.  
  89. (*------  Close everything:  ------*)
  90.  
  91.   IF Window#NIL THEN CloseWindow(Window); END;
  92.  
  93. (*------  Remove Port:  ------*)
  94.  
  95.   IF MyPort#NIL THEN
  96.     Forbid();
  97.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  98.       WHILE QuitMessage#NIL DO
  99.         ReplyMsg(QuitMessage);
  100.         QuitMessage := GetMsg(MyPort);
  101.       END;
  102.       DeletePort(MyPort);
  103.     Permit();
  104.   END;
  105.  
  106. END CleanUp;
  107.  
  108. (*------  MAIN:  ------*)
  109.  
  110. BEGIN
  111.  
  112. (*------  Initialization:  ------*)
  113.  
  114.   WBScreen := NIL; Window := NIL; MyPort := NIL;
  115.   OldPlane1 := NIL; OldPlane2 := NIL; OldbPR := 0; OldRows := 0;
  116.   TermProcedure(CleanUp);
  117.  
  118. (*------  Have we already been started?  ------*)
  119.  
  120.   OldPort := FindPort(ADR(PortName));
  121.   IF OldPort#NIL THEN
  122.     MyPort := CreatePort(ADR(ReplyName),0);
  123.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  124.     MyMsg.node.type := message;
  125.     MyMsg.replyPort := MyPort;
  126.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  127.     WaitPort(MyPort);
  128.     DeletePort(MyPort);
  129.     MyPort := NIL;
  130.     Terminate(0);
  131.   END;
  132.   MyPort := CreatePort(ADR(PortName),0);
  133.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  134.  
  135. (*------  Open Window:  ------*)
  136.  
  137.   WITH NuWindow DO
  138.     leftEdge   := 0; topEdge     := 0;
  139.     width      := 1; height      := 1;
  140.     detailPen  := 0; blockPen    := 1;
  141.     idcmpFlags := IDCMPFlagSet{};
  142.     flags      := WindowFlagSet{backDrop};
  143.     firstGadget:= NIL; checkMark := NIL;
  144.     title      := ADR(WindowTitle);
  145.     screen     := NIL; bitMap    := NIL;
  146.     type       := ScreenFlagSet{wbenchScreen};
  147.   END;
  148.   Window := OpenWindow(NuWindow);
  149.   Assert(Window#NIL,ADR("Can't open Window!!!"));
  150.   WBScreen := Window^.wScreen;
  151.   IF WBScreen^.bitMap.depth>2 THEN Terminate(0) END; (* thers sth. strange ! *)
  152.  
  153. (*------  Set Colors:  ------*)
  154.  
  155.   ColTable := WBScreen^.viewPort.colorMap^.colorTable;
  156.   FOR l:=4 TO 12 BY 4 DO
  157.     ColTable^[l] := CAST(INTEGER,CAST(BITSET,ColTable^[0] DIV 2)*{0..2,4..6,8..10});
  158.     ColTable^[1+l] := ColTable^[1];
  159.     ColTable^[2+l] := ColTable^[2];
  160.     ColTable^[3+l] := ColTable^[3];
  161.   END;
  162.  
  163. (*------  Add Plane to WBScreen:  ------*)
  164.  
  165.   bm := WBScreen^.bitMap;
  166.   WITH bm DO
  167.     INC(rows,8);
  168.     INC(bytesPerRow,2);
  169.     AllocMem(NewPlane1,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
  170.     AllocMem(NewPlane2,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
  171.     Assert((NewPlane1#NIL) AND (NewPlane2#NIL),ADR("Out of memory"));
  172.     planes[0] := NewPlane1;
  173.     planes[1] := NewPlane2;
  174.   END;
  175.   WITH WBScreen^ DO
  176.     l := BltBitMap(ADR(bitMap),0,0,ADR(bm),16,8,width,height,0C0H,3,NIL);
  177.     WITH bitMap DO
  178.       Forbid();
  179.         OldPlane1 := planes[0];
  180.         OldPlane2 := planes[1];
  181.         planes[0] := NewPlane1;
  182.         planes[1] := NewPlane2;
  183.         planes[2] := NewPlane1;
  184.         planes[3] := NewPlane2;
  185.         OldRows   := rows; OldbPR := bytesPerRow;
  186.         INC(rows,8); INC(bytesPerRow,2);
  187.         INC(planes[0],8*bytesPerRow+2);
  188.         INC(planes[1],8*bytesPerRow+2);
  189.       Permit();
  190.  
  191. (*------  Do it:  ------*)
  192.  
  193.       REPEAT
  194.         Forbid();
  195.           depth := 4;
  196.           MakeScreen(WBScreen);
  197.           depth := 2;
  198.         Permit();
  199.         RethinkDisplay();
  200.         Delay(10);
  201.         QuitMessage := GetMsg(MyPort);
  202.       UNTIL QuitMessage#NIL;
  203.     END;
  204.   END;
  205.  
  206. END RealWBShadow.
  207.